The Arsenal Files 8/The Arsenal Files Collection #8 (Arsenal Computer) (1996).ISO/prg_basi/pa16v305.zip/TEST30.BAS

BASIC Source File | 1996-02-20 | 11KB | 397 lines

' Tuomas Salste
' File name parsing library
' Included as an example for Project Analyzer
' These functions will not necessarily work

Option Explicit
DefInt A-Z

Type FilenameType
   drive As String '* 8
   Path As String '* 63
   Filename As String '* 12
   Basename As String '* 8
   Extension As String '* 3
End Type

Global FName As FilenameType

Global Const DRIVE_FLOPPY = 2
Global Const DRIVE_FIXED = 1
Global Const DRIVE_NETWORK = 0

' DiskSpaceFree function uses this in SETUPKIT.DLL
' Not needed if not used
Declare Function DiskSpaceFree_DLL Lib "SETUPKIT.DLL" Alias "DiskSpaceFree" () As Long

Function AbsPath (ByVal BaseDir As String, ByVal Path As String) As String
' Gives Absolute Path from Relative Path

Dim GivenPath As FilenameType
Dim Result As Integer
Result = FileNameSplit(Path, GivenPath)
If GivenPath.drive <> "" Then
    On Error Resume Next
    BaseDir = CurDir(GivenPath.drive)
    If Err Then
    BaseDir = GivenPath.drive + "\"
    End If
    On Error GoTo 0
Else
    If BaseDir = "" Then
    BaseDir = CurDir
    End If
End If

Dim nDir As String
Do While Path <> ""
    nDir = NextDir(Path)
    Select Case nDir
    Case ".."
        Dim BackPath As FilenameType
        Result = FileNameSplit(BaseDir, BackPath)
        BaseDir = BackPath.Path
    Case "."
    Case "\"
        BaseDir = DriveOnly(BaseDir) + "\"
    Case Else
        BaseDir = PathNameWithSlash(BaseDir) & nDir
    End Select
Loop
AbsPath = UCase(BaseDir)

End Function

Function Basenameonly (ByVal FileSpec As String) As String
' Returns the base name of a filespec
' FileSpec can be a directory name too

Dim Filename As FilenameType
Dim Result As Integer
Result = FileNameSplit(FileSpec, Filename)
Basenameonly = Filename.Basename

End Function

Function ChangeFilenameExtension (ByVal OldFilename As String, ByVal NewExtension As String) As String
' Example:
' ChangeFilenameExtension("AUTOEXEC.BAT", "TMP")
' results in "AUTOEXEC.TMP"
' Returns "" in error

Dim File As FilenameType
If FileNameSplit(OldFilename, File) Then
    File.Extension = NewExtension
    File.Filename = File.Basename & "." & File.Extension
    ChangeFilenameExtension = FileNameExpand(File)
Else
    Exit Function
End If

End Function

'------------------------------------------------
' Get the disk space free for the current drive
'------------------------------------------------
Function DiskSpaceFree (drive As String) As Long

Dim OldDrive As String
OldDrive = DriveOnly(CurDir)

On Error Resume Next
ChDrive drive
If Err = 0 Then
    DiskSpaceFree = DiskSpaceFree_DLL()
End If
ChDrive OldDrive

End Function

Function DriveOnly (ByVal FileSpec As String) As String
' Returns the drive "D:"

Dim File As FilenameType
If FileNameSplit(FileSpec, File) Then
    DriveOnly = File.drive
End If

End Function

Function DriveType (ByVal DriveLetter As String, DriveListBox As DriveListBox) As Integer
' Returns the type of a drive
' Type is one of the following:
' DRIVE_FLOPPY, DRIVE_FIXED, DRIVE_NETWORK

Dim i As Integer
For i = 0 To DriveListBox.ListCount - 1
    If StrComp(Left(DriveListBox.List(i), 1), Left(DriveLetter, 1), 1) = 0 Then
    If Len(DriveListBox.List(i)) = 2 Then
        DriveType = DRIVE_FLOPPY
    ElseIf Mid(DriveListBox.List(i), 3, 2) = "\\" Then
        DriveType = DRIVE_NETWORK
    Else

        DriveType = DRIVE_FIXED
    End If
    Exit For
    End If
Next

End Function

Function ExtensionOnly (ByVal File As String) As String
' Returns file name extension "BAS"
' This is a global function that will be overridden
' by local function ExtensionOnly defined in PROJTEST.FRM
' So this function is dead

Dim Filename As FilenameType
Dim Result As Integer
Result = FileNameSplit(File, Filename)
ExtensionOnly = Filename.Extension

End Function

Private Function FileNameExpand (Filename As FilenameType) As String
' Assembles a qualified file name from separate fields

Dim Delimiter$
If Len(RTrim$(Filename.drive)) > 2 Then
    If Filename.drive = String$(8, 0) Then
    FileNameExpand$ = ""
    Else
    FileNameExpand$ = RTrim$(Filename.drive)
    End If
Else
    If Right$(RTrim$(Filename.Path), 1) = ":" Or RTrim$(Filename.Path) = "" Or Right$(RTrim$(Filename.Path), 1) = "\" Then
    Else
    Delimiter$ = "\"
    End If
    If Left$(Filename.Path, 2) = RTrim$(Filename.drive) Then
    FileNameExpand$ = UCase$(RTrim$(Filename.Path) + Delimiter$ + RTrim$(Filename.Filename))
    Else
    FileNameExpand$ = UCase$(RTrim$(Filename.drive) + RTrim$(Filename.Path) + Delimiter$ + RTrim$(Filename.Filename))
    End If
End If

End Function

Function FilenameOnly (ByVal FileSpec As String) As String
' Returns the file name part of a FileSpec "FILENAME.BAS"

Dim File As FilenameType
If FileNameSplit(FileSpec, File) Then
    FilenameOnly = File.Filename
End If

End Function

Function FileNameSplit (ByVal FilenameString$, Filename As FilenameType) As Integer
' Splits a file name into separate fields

Dim er As Integer
Dim FilNam$
Dim Colon As Integer
Dim NoDrive As Integer
Dim c As Integer

FilNam$ = UCase$(FilenameString$)
Filename.drive = ""
Filename.Path = ""
Filename.Filename = ""
Filename.Basename = ""
Filename.Extension = ""
Colon = InStr(FilNam$, ":")
If Colon = 2 Then
    Filename.drive = Left$(FilNam$, 2)
ElseIf Colon Then
    If Len(FilNam$) > Colon Or Colon < 4 Or Colon > 5 Then
    er = True
    Else
    NoDrive = True
    Filename.drive = Left$(FilNam$, Colon)
    End If
End If
If er = 0 And NoDrive = False Then
    For c = Len(FilNam$) To 1 + Len(RTrim$(Filename.drive)) Step -1
    If Mid$(FilNam$, c, 1) = "\" Then
        If c = Len(RTrim$(Filename.drive)) + 1 Then
        Filename.Path = Left$(FilNam$, c)
        Else
        Filename.Path = Left$(FilNam$, c - 1)
        End If
        Exit For
    End If
    Next
    If RTrim$(Mid$(FilNam$, c + 1)) <> ".." Then
    If InStr(Mid$(FilNam$, c + 1), ".") Then
        Filename.Basename = Left$(Left$(Mid$(FilNam$, c + 1), InStr(Mid$(FilNam$, c + 1), ".") - 1), 8)
        Filename.Extension = Mid$(Mid$(FilNam$, c + 1), InStr(Mid$(FilNam$, c + 1), ".") + 1, 3)
    Else
        Filename.Basename = Mid$(FilNam$, c + 1)
    End If
    Else
    Filename.Path = RTrim$(Filename.Path) + ".."
    End If
    If RTrim$(Filename.Basename) = "" And RTrim$(Filename.Extension) <> "" Then
    er = True
    Filename.Extension = ""
    Filename.Path = ""
    Filename.drive = ""
    Else
    If Len(RTrim$(Filename.Extension)) Then
        Filename.Filename = RTrim$(Filename.Basename) + "." + Filename.Extension
    Else
        Filename.Filename = RTrim$(Filename.Basename)
    End If
    If RTrim$(Filename.Filename) = "." Then Filename.Filename = ""
    End If
End If
If er Then
    FileNameSplit% = False
Else
    FileNameSplit% = True
End If

End Function

Function IsDir (ByVal FileSpec As String) As Integer

Dim Result As Integer
On Local Error Resume Next
Result = GetAttr(FileSpec)
If Err = 0 And Result = 16 Then ' ATTR_DIRECTORY= 16
    IsDir = True
End If

End Function

Function IsFile (ByVal FileSpec As String) As Integer
' Returns True if a file called Filename exists
' Filename CAN NOT contain wildcards

Dim Result As String
On Local Error Resume Next
Result = Dir(FileSpec)
If Err = 0 And LCase(Result) = LCase(FilenameOnly(FileSpec)) And Result <> "" Then
    IsFile = True
End If

End Function

Function IsFileSpec (ByVal Filename As String) As Integer
' Returns True if Filename is
' a file, a directory or a volume label
' Filename must not contain any wildcards

Dim Result As Integer
On Local Error Resume Next
Result = GetAttr(Filename)
If Err = 0 Then IsFileSpec = True

End Function

Function MatchesTemplate% (TestText$, Template$)
' Checks if a file name matches Template ("FILENAME.BAS", "*.BAS")

Dim CheckLen As Integer, c As Integer
Dim TChar$, NoMatch As Integer

If Len(Template$) > Len(TestText$) Then
    CheckLen = Len(Template$)
Else
    CheckLen = Len(TestText$)
End If
For c = 1 To CheckLen
    TChar$ = Mid$(Template$, c, 1)
    Select Case TChar$
    Case "?"
    Case "*"
        Exit For
    Case Mid$(TestText$, c, 1)
    Case ""
        NoMatch = True
        Exit For
    Case Else
        NoMatch = True
        Exit For
    End Select
Next
If Len(Template$) > Len(TestText$) Then
    If InStr(Template$, "*") = False And Mid$(Template$, Len(TestText$) + 1, Len(Template$) - Len(TestText$)) <> String$(Len(Template$) - Len(TestText$), "?") Then
    NoMatch = True
    End If
End If
If Not NoMatch Then MatchesTemplate = True

End Function

Function NextDir (Path As String) As String
' Returns the next directory name in a long Path string
' NextDir("D:\VB30\LIB\FILENAME.BAS") = "VB30"

Dim NewPath As String
If Mid(Path, 2, 1) = ":" Then
    NewPath = Mid(Path, 3)
Else
    NewPath = Path
End If
Select Case InStr(NewPath, "\")
    Case 0
    NextDir = NewPath
    Path = ""
    Case 1
    NextDir = "\"
    Path = Mid(NewPath, 2)
    Case Else
    NextDir = Left(NewPath, InStr(NewPath, "\") - 1)
    Path = Mid(NewPath, InStr(NewPath, "\") + 1)
End Select

End Function

Private Function PathNameOnly_FromDir (ByVal Directory As String) As String
' Returns the path name part of a path string
' PathnameOnly_FromDir("D:\VB30\LIB") = "\VB30\LIB"

Dim WholePath As FilenameType
Dim Result As Integer
Result = FileNameSplit(PathNameWithSlash(Directory) + "*.*", WholePath)
If WholePath.drive <> "" Then
    PathNameOnly_FromDir = Mid(WholePath.Path, Len(WholePath.drive) + 1)
Else
    PathNameOnly_FromDir = WholePath.Path
End If

End Function

Function PathnameWithoutSlash (ByVal FileSpec As String) As String
' Returns a path name from a filespec without the ending slash
' The result can be used in ChDir, for example
' PathnameWithoutSlash("D:\VB30\LIB\FILENAME.BAS") = "D:\VB30\LIB"

Dim File As FilenameType
If FileNameSplit(FileSpec, File) Then
    PathnameWithoutSlash = File.Path
End If

End Function

Function PathNameWithSlash (ByVal Path$) As String
' Returns a path name without the ending slash
' The result can be used in building filespecs, for example
' PathnameWithSlash("D:\VB30\LIB") = "D:\VB30\LIB\"

If Right$(RTrim$(Path$), 1) = ":" Or RTrim$(Path$) = "" Or Right$(RTrim$(Path$), 1) = "\" Then
    PathNameWithSlash = Path$
Else
    If IsFile(Path$) Then
    PathNameWithSlash = PathNameWithSlash(AbsPath(Path$, ".."))
    Else
    PathNameWithSlash = Path$ + "\"
    End If
End If

End Function